;;;; RLlib copyright 2010 Adam White (theroguemonkey@gmail.com)
;;;; Licensed under GNU General Public Licence v2 or later - refer COPYING

(in-package #:rllib)


(defparameter *panels* nil
  "List of all panels created")

(defparameter *cache* (make-hash-table :test #'eq))

(defparameter *current-panel* nil
  "Current panel being rendered")

(defparameter *dimensions* nil
  "Base dimensions of screen `(0 0 ,WIDTH ,HEIGHT)")

(defgeneric dispose (thing)
  (:documentation "Free THING from use"))

(defgeneric texture (id))
(defgeneric output-texture (texture x y))
(defgeneric output-string (font string rcolour x y))
(defgeneric parse-rc (id type filename &rest data))

;;;; Font handling is from:
;;;; GLFT_Font (http://polimath.com/blog/code/glft_font/)
;;;; by James Turk (james.p.turk@gmail.com)
;;;; Based on work by Marijn Haverbeke (http://marijn.haverbeke.nl)
(cffi:defcfun ("GLFT_init" glft-init) :void)
(cffi:defcfun ("GLFT_quit" glft-quit) :void)
(cffi:defcfun ("GLFT_open" glft-open) :pointer (filename :string) (ptsize :int))
(cffi:defcfun ("GLFT_close" glft-close) :void (font :pointer))
(cffi:defcfun ("GLFT_height" glft-height) :int (font :pointer))
(cffi:defcfun ("GLFT_width" glft-width) :int (font :pointer) (string :string))
(cffi:defcfun ("GLFT_render" glft-render) :void (font :pointer) (string :string))


(defun set-ortho (x y w h)
  (gl:viewport x y w h)
  (gl:matrix-mode :projection)
  (gl:load-identity)  
  (gl:ortho 0 w 0 h 0 1)  
  (gl:scale 1 -1 1)
  (gl:translate 0 (- h) 0)
  (gl:matrix-mode :modelview))

(defun opengl-init ()
  (gl:front-face :cw)
  (gl:enable :texture-2d)
  (gl:enable :blend)
  (gl:enable :alpha-test)
  (gl:enable :line-smooth)
  (gl:enable :point-smooth)
  (gl:enable :polygon-smooth)
  (gl:enable :cull-face)
  (gl:enable :scissor-test)
  (gl:blend-func :src-alpha :one-minus-src-alpha)
  (gl:alpha-func :greater 0.1)
  (gl:clear-color 0.0 0.0 0.0 0.0)
  (gl:clear :color-buffer-bit)
  (setf *cache* (make-hash-table :test #'eq)
	*dimensions* (list 0 0 *screen-w* *screen-h*))
  (apply #'set-ortho *dimensions*)
  (il:init)
  (glft-init))


(defun opengl-quit ()
  (map nil #'dispose (loop for c being the hash-values of *cache* collect c))
  (clrhash *cache*)
  (glft-quit))


(defmacro with-opengl-init ((width height &optional (title "RLLIB OpenGL/SDL application")) &body body)
  `(unwind-protect
	(progn
	  (load-dlls)
	  (sdl-init '(:init-video :init-audio))
	  (sdl-gl-set-attribute :gl-doublebuffer 1)
	  (sdl-gl-set-attribute :gl-red-size 8)
	  (sdl-gl-set-attribute :gl-green-size 8)
	  (sdl-gl-set-attribute :gl-blue-size 8)
	  (sdl-gl-set-attribute :gl-alpha-size 8)
	  (setf *screen* (sdl-set-video-mode ,width ,height 32 '(:opengl :doublebuf :resizable))
		*screen-w* ,width
		*screen-h* ,height)
	  (opengl-init)
	  (sdl-enable-unicode)
	  (sdl-enable-key-repeat 500 40)
	  (sdl-wm-set-caption ,title (cffi::null-pointer))
	  ,@body) 
     (progn
       (opengl-quit)
       (sdl-quit)
       (unload-dlls))))

;;;;============================================================================
;;;; Colours
;;;;============================================================================

(defclass colour ()
  ((rgba 
    :initarg :rgba 
    :accessor colour-rgba)))

(defun make-colour (&rest rgba)
  (make-instance 'colour :rgba 
		 (mapcar (lambda (a) (/ a 255.0))
			 (if (= (length rgba) 4) rgba (append rgba (list 255))))))

(defparameter +black+      (make-colour   0    0    0))
(defparameter +aqua+       (make-colour   0  255  255))
(defparameter +banana+     (make-colour 227  207   87))
(defparameter +brown+      (make-colour 139   69   19))
(defparameter +cornflower+ (make-colour 100  149  237))
(defparameter +dblue+      (make-colour   0    0  205))
(defparameter +dgreen+     (make-colour  34  139   34))
(defparameter +dgrey+      (make-colour 128  128  128))
(defparameter +dodgerblue+ (make-colour  30  144  255))
(defparameter +flesh+      (make-colour 255  125   64))
(defparameter +gold+       (make-colour 255  215    0))
(defparameter +goldenrod+  (make-colour 218  165   32))
(defparameter +ivory+      (make-colour 255  255  240))
(defparameter +lblue+      (make-colour 100  148  237))
(defparameter +lgreen+     (make-colour 124  252    0))
(defparameter +lgrey+      (make-colour 192  192  192))
(defparameter +magenta+    (make-colour 238    0  238))
(defparameter +olive+      (make-colour 128  128    0))
(defparameter +orange+     (make-colour 255  165    0))
(defparameter +peacock+    (make-colour  51  161  201))
(defparameter +pink+       (make-colour 255  182  193))
(defparameter +purple+     (make-colour 128    0  128))
(defparameter +red+        (make-colour 220   20   60))
(defparameter +rosybrown+  (make-colour 139  105  105))
(defparameter +salmon+     (make-colour 255  160  122))
(defparameter +skyblue+    (make-colour 135  206  255))
(defparameter +slateblue+  (make-colour 122  103  238))
(defparameter +tan+        (make-colour 210  180  140))
(defparameter +white+      (make-colour 255  255  255))                     
(defparameter +yellow+     (make-colour 255  215    0))

(defvar +colours+ (vector +black+ +aqua+ +banana+ +brown+ +cornflower+ +dblue+ +dgreen+ +dgrey+ +dodgerblue+ 
			  +flesh+ +gold+ +goldenrod+ +ivory+ +lblue+ +lgreen+ +lgrey+ +magenta+ +olive+
			  +orange+ +peacock+ +pink+ +purple+ +red+ +rosybrown+ +salmon+ +skyblue+ +slateblue+ 
			  +tan+ +white+ +yellow+))

(defun random-colour ()
  (svref +colours+ (1+ (random (1- (length +colours+))))))

(defun random-colour* ()
  (make-colour (1+ (random 254)) (1+ (random 254)) (1+ (random 254))))

(defun colourp (obj)
  (typep obj 'colour))

(defun colour (colour)
  (apply #'gl:color (colour-rgba colour)))

(defun output-colour (colour x y w h)
  (when (not-cull-p x y w h)
    (gl:disable :texture-2d)
    (colour colour)    
    (gl:with-primitive :quads
      (gl:vertex x y)
      (gl:vertex (+ x w) y)
      (gl:vertex (+ x w) (+ y h))
      (gl:vertex x (+ y h)))
    (gl:enable :texture-2d)))

(defun make-output-colour (colour x y w h)
  (list #'output-colour colour x y w h))

(defun output-vertex (colour x y)
  (colour colour)
  (gl:vertex x y))

(defun output-lines (list-of-vertices)
  (gl:polygon-mode :front :fill)
  (gl:with-primitive :polygon 
    (map nil (lambda (v) (apply #'output-vertex v)) list-of-vertices)))

(defun make-output-lines (list-of-vertices)
  (list #'output-lines list-of-vertices))

;;;;============================================================================
;;;; Fonts
;;;;============================================================================

(defclass font ()  
  ((font
    :initarg :font
    :reader font)
   (size
    :initarg :size
    :reader font-ptsize)))

(defmethod dispose ((font font))
  (glft-close (font font)))

(defun make-font (id path size)
  (or (gethash id *cache*)
      (let ((font (make-instance 'font :font (glft-open (path->file path) size) :size size)))
	(setf (gethash path *cache*) font
	      (get id :font) font))))

(defun get-font (id)
  (get id :font))

(defun font-height (font)
  (glft-height (font font)))

(defun font-width (font string)
  (glft-width (font font) string))

(defmethod output-string ((font symbol) string colour x y)
  (output-string (get-font font) string colour x y))

(defmethod output-string ((font font) (string string) (colour colour) x y)
  (when (not-cull-p x y 0 0)
    (colour colour)    
    (gl:with-pushed-matrix
      (gl:translate x y 0)    
      (glft-render (font font) string))))

(defmethod output-string (font string colour x y)
  (output-string font (mkstring string) colour x y))

(defun make-output-string (font string colour x y)
  (list #'output-string font string colour x y))

(defun output-multi-string (font colour width x y strings)
  (map nil (lambda (s) (apply #'output-string nil font s))
       (split-text-for-output strings colour width font x y)))

(defun make-output-multi-string (font colour width x y &rest strings)
  (list #'output-multi-string font colour width x y strings))

(defun split-text-for-output (texts colour width font x y &aux (margin x) (height (font-height font)))
  (labels ((split-word (word split)
	     (push (subseq word split) texts)
	     (gen-output (subseq word 0 split)))
	   (carriage-return (word)
	     (setf x margin y (+ y height))
	     (gen-output word))
	   (gen-output (word)
	     (when (= x margin)
	       (setf word (string-left-trim '(#\Space #\Tab) word)))
	     (let ((render-len (font-width font word)))
	       (cond
		 ;; simplest case - it fits perfectly
		 ((<= (+ render-len x) (+ margin width))
		  (prog1
		      (list word colour x y)
		    (incf x render-len)))
		 ;; massive line that can't be split, so dump the word and start a new line
		 ((and (= x margin) (not (find #\Space word)))
		  (prog1
		      (list word colour x y)
		    (setf x margin y (+ y height))))
		 ;; won't fit but maybe can be split
		 (t
		  (let ((split (or (position #\Space word :from-end t) 0)))
		    (if (plusp split)
			;; yes can be split
			(split-word word split)
			;; start a new line and try again
			(carriage-return word))))))))
    
    (reduce-adjacent (lambda (a b) (and (eq (second a) (second b)) (/= (third b) margin)))
		     (lambda (a b) (cons (strcat (first a) (first b)) (rest a)))
		     (loop for word = (pop texts) until (null word)
			when (typep word 'colour) do (setf colour word)
			else collect (gen-output (mkstring word))))))



;;;;============================================================================
;;;; Textures
;;;;============================================================================

(defclass texture ()
  ((id
    :initarg :id
    :reader texture-id)
   (width
    :initarg :w
    :reader texture-w)
   (height
    :initarg :h
    :reader texture-h)))


(defclass seamless-texture (texture)
  ())

(defmethod dispose ((texture texture))
  (gl:delete-textures (list (texture-id texture))))

(defun %load-texture (filename &aux (texture-id (car (gl:gen-textures 1))) (devil (il:gen-image)))
  (il:bind-image devil)
  (il:load-image (path->file filename))
  (let* ((width (il:get-integer :image-width))
	 (height (il:get-integer :image-height))
	 (bytes-per-pixel (il:get-integer :image-bpp))
	 (internal-format (case bytes-per-pixel (1 :luminance8) (2 :luminance8-alpha8) (3 :rgb8) (4 :rgba8)))
	 (format (case bytes-per-pixel (1 :luminance) (2 :luminance-alpha) (3 :rgb) (4 :rgba))))    
    (gl:bind-texture :texture-2d texture-id)
    (gl:tex-image-2d :texture-2d 0 internal-format width height 0 format :unsigned-byte (il:get-data))
    (il:delete-images devil)
    (gl:tex-parameter :texture-2d :texture-min-filter :linear)
    (gl:tex-parameter :texture-2d :texture-mag-filter :linear)
    (gl:tex-parameter :texture-2d :texture-wrap-s :repeat)
    (gl:tex-parameter :texture-2d :texture-wrap-t :repeat)
    (gl:tex-env :texture-env :texture-env-mode :modulate)
    (list :id texture-id :w width :h height)))
     
(defun make-texture (id pathname)
  (or (gethash pathname *cache*)
      (let ((texture (apply #'make-instance 'texture (%load-texture (path->file pathname)))))
	(setf (gethash pathname *cache*) texture)
	(when id (setf (get id :texture) texture)))))

(defun make-seamless-texture (id pathname)
  (or (gethash pathname *cache*)
      (let ((texture (apply #'make-instance 'seamless-texture (%load-texture (path->file pathname)))))
	(setf (gethash pathname *cache*) texture)
	(when id (setf (get id :texture) texture)))))

(defmethod texture ((texture texture))
  texture)

(defmethod texture ((id symbol))
  (get id :texture))

(defmethod texture ((path string))
  (make-texture nil path))

(defmethod texture ((path pathname))
  (make-texture nil path))

(defmethod output-texture ((texture symbol) x y)
  (output-texture (texture texture) x y))

(defmethod output-texture ((texture texture) x y)
  (gl:color 1.0 1.0 1.0 1.0)
  (gl:bind-texture :texture-2d (texture-id texture))
  (let ((w (texture-w texture))
	(h (texture-h texture)))
    (when (not-cull-p x y w h)
      (gl:with-primitive :quads
	(gl:tex-coord 0.0 0.0) (gl:vertex x y)
	(gl:tex-coord 1.0 0.0) (gl:vertex (+ x w) y)
	(gl:tex-coord 1.0 1.0) (gl:vertex (+ x w) (+ y h))
	(gl:tex-coord 0.0 1.0) (gl:vertex x (+ y h))))))

(defmethod output-texture ((texture seamless-texture) x y)
  (gl:color 1.0 1.0 1.0 1.0)
  (gl:bind-texture :texture-2d (texture-id texture))
  (when (not-cull-p x y 32.0 32.0)  
    (let* ((w (texture-w texture)) (h (texture-h texture))
	   (x1 (/ x w)) (y1 (/ y h)) (x2 (/ (+ x 33.0) w)) (y2 (/ (+ y 33.0) h)))
      (gl:with-primitive :quads
	(gl:tex-coord x1 y1) (gl:vertex x y)
	(gl:tex-coord x2 y1) (gl:vertex (+ x 32.0) y)
	(gl:tex-coord x2 y2) (gl:vertex (+ x 32.0) (+ y 32.0))
	(gl:tex-coord x1 y2) (gl:vertex x (+ y 32.0))))))

(defun make-output-texture (texture x y)
  (list #'output-texture texture x y))


;;;;============================================================================
;;;; Init file reading
;;;;============================================================================

(defmethod parse-rc (id (type (eql :texture)) (filename string) &rest data)
  (make-texture id (path->file filename))
  (loop for (key val) on data by #'cddr do (setf (get id key) val)))

(defmethod parse-rc (id (type (eql :seamless-texture)) (filename string) &rest data)
  (make-seamless-texture id (path->file filename))
  (loop for (key val) on data by #'cddr do (setf (get id key) val)))

(defmethod parse-rc (id (type (eql :font)) (filename string) &rest data)
  (make-font id (path->file filename) (car data))
  (loop for (key val) on (cdr data) by #'cddr do (setf (get id key) val)))

(defmethod parse-rc (id (type (eql :data)) first &rest rest)
  (loop for (key val) on (cons first rest) by #'cddr do (setf (get id key) val)))

(defun read-rc-file (filename)
  (with-open-file (stream (path->file filename))
    (let ((*read-eval* nil)
	  (file (read stream)))
      (map nil (lambda (f) (apply #'parse-rc f)) file))))